# $Id: db.tcl 46 2007-09-09 16:46:20Z khomoutov $
# Sample sketch that creates an SQLite3 database with a single share
# and populates that database with info on files of a given directory
# which is scanned recursively.

# TODO
# * Implement [share update].
# * provide -progresscmd & -errorcmd to proc that populate/update share
#   for client code to be able to receive info on each processed file
#   and on non-fatal errors like failure to open a file.
# ? Implement a kind of custom [catch] that checks an error internally
#   to be POSIX and behaves differently based on this.
# * Implement possibility to generate one filelist for a set of shares.
# * Complete interface to shares (provide for re-rooting a share).
# * Implement possibility to restrict searching to a list of shares.
#   Probably "share groups" is the best bet (with the concept
#   "one share group per hub").
# * Think of dropping the concept of keeping parent path and file name
#   separate since DC++-based clients search on full paths (relative to
#   the share root), not just tailnames. This is questionable approach,
#   though, due to a number of reasons.
# * Try to rev-engeneer how "exact size" is specified in search requests
#   made by StrongDC++; also DC++ and StrongDC++ have "normal" size type.

package require tdom
package require tth

namespace export database share

proc database {op args} {
	switch -- $op {
		open {
			eval DatabaseOpen $args
		}
		close {
			db close
		}
		search {
			eval DatabaseSearch $args
		}
		default {
			return -code error "bad operation \"$op\":\
				must be one of open, close or search"
		}
	}
}

proc share {op args} {
	switch -- $op {
		create {
			eval ShareCreate $args
		}
		delete {
			eval ShareDelete $args
		}
		exists {
			eval ShareExists $args
		}
		populate {
			eval SharePopulate $args
		}
		update {
			eval ShareUpdate $args
		}
		xmlbzlist {
			eval ShareMakeXMLbzlist $args
		}
		dclist -
		nmdclist {
			eval ShareMakeNMDCList $args
		}
		desc {
			eval ShareDesc $args
		}
		default {
			return -code error "bad operation \"$op\":\
				must be one of create, delete, exists,\
				populate, update, xmlbzlist or dclist"
		}
	}
}

proc DatabaseOpen dbfile {
	sqlite [my db] [file normalize $dbfile]
	if {![db exists {select * from sqlite_master
			where type = 'table'}]} {
		DatabaseInit
	}

	db function file_join [my SQL_FileJoin]
}

proc DatabaseInit {} {
	db transaction {
		# File shares:
		db eval {
			CREATE TABLE shares (
				name  TEXT NOT NULL UNIQUE PRIMARY KEY,
				desc  TEXT,
				root  TEXT NOT NULL UNIQUE,
				mtime INTEGER,
				size  INTEGER NOT NULL DEFAULT 0
			)
		}

		# "Share groups" -- groups of related shares:
		db eval {
			CREATE TABLE sharegroups (
				name TEXT NOT NULL UNIQUE PRIMARY KEY,
				desc TEXT
			)
		}

		# Binds shares to share groups:
		db eval {
			CREATE TABLE g2s (
				sgroup TEXT NOT NULL,
				share  TEXT NOT NULL,
				UNIQUE (sgroup, share)
			)
		}

		# Files (bound to shares):
		db eval {
			CREATE TABLE files (
				TTH    TEXT,
				name   TEXT NOT NULL,
				parent TEXT NOT NULL,
				type   INTEGER NOT NULL,
				mtime  INTEGER,
				size   INTEGER,
				share  TEXT,
				UNIQUE (name, type, parent)
			)
		}

		db eval {CREATE INDEX ix_files_TTH ON files (TTH)}
		db eval {CREATE INDEX ix_files_name ON files (name)}
	}
}

# Parameter checking for -{min|max}size is expected to be performed
# on higher level.
proc DatabaseSearch args {
	set mediatype any; set type 1
	set keywords [list]
	set sizerest none
	set size 0
	set shares {}

	foreach {opt val} $args {
		switch -- $opt {
			-minsize  {
				if {[string equal $sizerest max]} {
					return -code error "-minsize and -maxsize cannot be used together"
				}
				set sizerest min
				set size $val
			}
			-maxsize  {
				if {[string equal $sizerest min]} {
					return -code error "-minsize and -maxsize cannot be used together"
				}
				set sizerest max
				set size $val
			}
			-type -
			-media - 
			-mediatype {
				set mediatype $val
				set type [mediatypeindex $val]
			}
			-keywords { set keywords $val }
			default   {
				return -code error "bad option \"$opt\":\
					must be one of -media, -keywords"
			}
		}
	}

	if {[llength $keywords] == 0} {
		return {}
	}

	switch -- $mediatype {
		TTH {
			return [DatabaseSearchForTTH [lindex $keywords 0] $sizerest $size]
		}
		default {
			return [DatabaseSearchForNames $type $keywords $sizerest $size]
		}
	}
}

proc DatabaseSearchForTTH {keyword sizerest size} {
	set keyword [string trimleft [string toupper $keyword] TTH:]
	set stmt {
		select file_join('/', s.name, f.parent, f.name) as name
		from shares s, files f
		where f.TTH = $keyword
	}
	
	switch -- $sizerest {
		min { append stmt { and f.size > $size } }
		max { append stmt { and f.size < $size } }
	}

	set results [list]
	db eval $stmt { lappend results $name }
	set results
}

proc DatabaseSearchForNames {type keywords sizerest size} {
	set stmt {
		select file_join('/', s.name, f.parent, f.name) as name
		from shares s, files f
		where 1 == 1
	}

	if {$type != 1} { # not "any"
		append stmt { and type = $type }
	}

	switch -- $sizerest {
		min { append stmt { and f.size > $size } }
		max { append stmt { and f.size < $size } }
	}

	set ix 0
	set selectors [list]
	foreach keyword $keywords {
		set keyword$ix %[string map {% |% _ |_} $keyword]%
		lappend selectors "f.name like \$keyword$ix escape '|'"
		incr ix
	}
	append stmt and ( [join $selectors " and "] )

	set results [list]
	db eval $stmt { lappend results $name }
	set results
}

proc SQL_FileJoin args {
	eval file join $args
}

proc ShareExists share {
	db exists {select * from shares where name = $share}
}

proc ShareEnsureExists share {
	if {![ShareExists $share]} {
		uplevel 1 [list return -code error "share \"$share\" does not exist"]
	}
}

proc ShareCreate {share root {desc ""}} {
	if {[ShareExists $share]} {
		return -code error "share \"$share\" already exists"
	}

	db eval {insert into shares (name, root) values ($share, $root)}

	if {$desc ne ""} {
		db eval {update shares set desc = $desc where name = $share}
	}
}

proc ShareDelete share {
	ShareEnsureExists $share

	db transaction {
		db eval {delete from shares where name = $share}
		db eval {delete from files where share = $share}
	}
}

proc ShareDesc args {
	if {[llength $args = 1]} {
		set share [lindex $args 0]
		db eval {select desc from shares where name = $share}
	} elseif {[llength $args = 2]} {
		foreach {share desc} $args break
		db eval {update shares set desc = $desc where name = $share}
	} else {
		return -code error "usage: ShareDesc share ?desc?"
	}
}

proc SharePopulate share {
	ShareEnsureExists $share

	set root [db eval {select root from shares where name = $share}]

	if {![file isdirectory $root]} {
		return -code error "share root \"$root\" is not a directory"
	}

	set nroot [file normalize $root]

	db transaction {
		db eval {delete from files where share = $share}
		AddFiles $share $nroot [llength [file split $nroot]]
		set mtime [file mtime $nroot]
		set size [db onecolumn {select sum(size) from files
			where share = $share}]
		db eval {update shares set mtime = $mtime,
			size = (select sum(size) from files where share = $share)
			where name = $share}
	}
}

proc RelPath {fname chop} {
	set chunks [lrange [file split [file dirname $fname]] $chop end]
	if {[llength $chunks] > 1} {
		return [eval file join $chunks]
	} else {
		return [lindex $chunks 0]
	}
}

proc AddFiles {share dir chop} {
	foreach f [glob -dir $dir -types f -nocomplain *] {
		set failed [catch {open $f} fd]
		if {$failed} {
			global errorCode errorInfo
			if {[string equal [lindex $errorCode 0] POSIX]} {
				puts stderr "failed to open file \"$f\": $fd"
				continue
			} else {
				return -code error -errorcode $errorCode -errorinfo $errorInfo $fd
			}
		}
		fconfigure $fd -translation binary
		set tth [tth::tth digest -chan $fd]
		close $fd

		set type   [filetype $f]
		set size   [file size $f]
		set mtime  [file mtime $f]
		set name   [file tail $f]
		set parent [RelPath $f $chop]

		db eval {
			insert into files
			(TTH, name, parent, type, mtime, size, share)
			values
			($tth, $name, $parent, $type, $mtime, $size, $share)
		}
	}

	foreach d [glob -dir $dir -types d -nocomplain *] {
		AddFiles $share $d $chop

		set mtime  [file mtime $d]
		set name   [file tail $d]
		set parent [RelPath $d $chop]

		db eval {
			insert into files
			(TTH, name, parent, type, mtime, share)
			values
			(NULL, $name, $parent, 8, $mtime, $share)
		}
	}
}

proc ShareMakeXMLbzlist {share fname} {
	ShareEnsureExists $share

	dom createDocument FileListing doc
	set root [$doc documentElement]
	$root setAttribute \
		Version    1 \
		CID        GABBAHEY \
		Base       / \
		Generator  "IncrDC 0.1"

	set node [ShareXMLizeDir $doc $root $share]
	ShareXMLProcessDir $share $doc $node ""

	file delete $fname
	set fd [open "| bzip2 -c9 >$fname" w]
	fconfigure $fd -translation binary

	puts $fd {<?xml version="1.0" encoding="utf-8" standalone="yes"?>}
	$root asXML -channel $fd -indent 1
	close $fd
	puts [llength [info comm ::dom*]]
}

proc ShareXMLProcessDir {share doc pnode parent} {
	db eval {select name from files
			where share = $share and type = 8 and parent = $parent} {
		set node [ShareXMLizeDir $doc $pnode $name]
		ShareXMLProcessDir $share $doc $node [file join $parent $name]
	}

	db eval {select name, size, TTH from files
			where share = $share and type != 8 and parent = $parent} {
		$pnode appendFromList [list File \
			[list Name $name Size $size TTH $TTH] {}]
	}
}

proc ShareXMLizeDir {doc pnode name} {
	set node [$pnode appendChild [$doc createElement Directory]]
	$node setAttribute Name $name
	set node
}

proc ShareMakeNMDCList {share fname} {
	ShareEnsureExists $share

	set encoding [encoding system]

	foreach {opt val} $args {
		switch -- $opt {
			-encoding { set encoding $val }
			default {
				return -code error "bad option \"$opt\":\
					must be -encoding"
			}
		}
	}

	set fd [open $fname w]
	fconfigure $fd -encoding $encoding -translation crlf

	puts $fd $share
	ShareNMDCProcessDir $fd $share 1 ""

	close $fd
}

proc ShareNMDCProcessDir {fd share level parent} {
	db eval {select name, size from files
			where share = $share and type != 8 and parent = $parent} {
		puts $fd [string repeat \t $level]$name|$size
	}

	db eval {select name from files
			where share = $share and type = 8 and parent = $parent} {
		puts $fd [string repeat \t $level]$name
		ShareNMDCProcessDir $fd $share [expr {$level + 1}] [file join $parent $name]
	}
}

